GetSysDir returns the path of the Windows System directory. Pass it the name of the string you want SysPath assigned to.
[Code]
'Declares for GetSystemDir
Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Sub GetSystemDir (SystemPath$)
DIM Sys As String * 256
x = GetSystemDirectory(Sys, Len(Sys))
x = InStr(1, Sys, Chr$(0))
SystemPath$ = Left$(Sys, Instr(Sys,Chr$(0))-1)
End Sub
[Stop]
[2]
Loaded tells if an app of the passed classname is loaded
[Code]
'Declares for Loaded
Declare Function FindWindow Lib "user" (ByVal CName As Any, ByVal Caption As Any)
Function Loaded (ClassName$)
Loaded = FindWindow(ClassName$, 0&)
End Function
[Stop]
[3]
RestoreApp restores the windows whose handle you pass to it.
[Code]
'Declares for RestoreApp
Declare Function IsIconic Lib "user" (ByVal hWnd As Any)
Sub RestoreApp (wHandle)
WM_SYSCOMMAND = &H112
SC_RESTORE = &HF120
If IsIconic(Instance) Then
T = PostMessage(Instance, WM_SYSCOMMAND, SC_RESTORE, 0)
WaitSecs 1
End If
End Sub
[Stop]
[4]
Tracks a popup menu.
Pass it the number (going from right to left) of the menu you wish to view, the X & Y coordinates at which it should pop up (as returned by a mousedown event), the form on which the mousedown event took place (and over which the menu should appear), and the form to which the menu belongs (which may or may not be the same as the previous form).
'2 tells it to use right mouse button, 1 the left button
r = TrackPopupMenu(hSubMenu%, 2, ix, iy, 0, MenuForm.hWnd, 0)
End Sub
[Stop]
[5]
Extracts icons from a specified Exe file.
[Code]
'Declares for IconExtractor
Const GWW_HINSTANCE = (-6)
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function ExtractIcon Lib "shell" (ByVal lpHandle As Integer, ByVal lpExe As String, ByVal lpiconindex As Integer) As Integer
Declare Function DrawIcon Lib "USER" (ByVal lpHandle As Integer, ByVal xcoord As Integer, ByVal ycoord As Integer, ByVal Hicon As Integer) As Integer
Sub IconExtractor (ExeFile$, F as Form, Pic as Picture)
Handle = F.hWnd
z = SCREEN.HEIGHT
Select Case z
Case 7000
X = 2: Y = 1
Case 7200
X = 3: Y = 0
Case 9000
X = 3: Y = 0
Case Is > 9000
X = 8: Y = 4
End Select
Static Looper
Looper = Looper + 1
Inst = GetWindowWord(Handle, GWW_HINSTANCE)
Hicon = ExtractIcon(Inst, ExeFile$, Looper - 1)
If Hicon = 0 Then
If Looper > 0 Then
Hicon = ExtractIcon(Inst, ExeFile$, 0)
Looper = 1
Else Beep: Exit Sub
End If
End If
F.Pic.CLS
Draw = DrawIcon(F.Pic.hDC, X, Y, Hicon)
End Sub
[Stop]
[6]
Testlength can be used to test whether more than a specified number of characters has been entered into a textbox. If so, it deletes backwards from the insertion point until the text length is within the specified limit.
[Code]
'Declares for TestLength
Global Const MB_ICONEXCLAMATION = 48
Sub TestLength (C As Control, L As Integer)
Select Case Len(C.Text)
Case Is <= L
Exit Sub
Case Else
MsgBox "This field is limited to " + Str$(L) + " characters only! ", MB_ICONEXCLAMATION, "CopyFlow"
LeftText$ = Left$(C.Text, C.SelStart)
RightText$ = Mid$(C.Text, C.SelStart + 1)
LeftText$ = Left$(LeftText$, L - Len(RightText$))
C.Text = LeftText$ + RightText$
End Select
End Sub
[Stop]
[7]
The Exists%() function returns a value of TRUE if the specified file exists, or FALSE if it doesn't.
Function IsValidPath (DestPath$, ByVal DefaultDrive$) As Integer
'----------------------------
' Remove left and right spaces
'----------------------------
DestPath$ = RTrim$(LTrim$(DestPath$))
'-----------------------------
' Check Default Drive Parameter
'-----------------------------
If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then
MsgBox "Bad default drive parameter specified in IsValidPath Function. You passed, """ + DefaultDrive$ + """. Must be one drive letter and "":"". For example, ""C:"", ""D:""...", 64, "Setup Kit Error"
Finds and restores a previous running instance of your app
[Code]
Sub FindAndRestorePrevInstance (Cap$)
Dim X%
If App.PrevInstance Then
AppActivate Cap$
SendKeys ("% R")
End
End If
End Sub
[Stop]
[20]
This code in Load procedure detects previous instance of program
[Code]
Sub Form_Load ()
If App.PrevInstance Then
msg$ = App.EXEName & " already running "
MsgBox msg$, 48
End
End If
End Sub
[Stop]
[21]
This routine will copy any size and type of file giving a visual progress indication to the user. Simply pass the Source Filename, Target Filename, and name of the control to use as a progress guage. The code below uses a standard Panel3D1 control from THREED.VBX but any control that gives the desired effect may be used. The progress range is 1 to 100 but can be any range.
[Code]
Sub VisualFileCopy (SourceFileName As String, TargetFileName As String,
ProgressGuage As Control)
Dim I As Integer
Dim SourceFileNo As Integer
Dim TargetFileNo As Integer
Dim SourceFileSize As Long
Dim CopyBuffer As String
On Error GoTo FileCopyErrorRoutine
SourceFileSize = FileLen(SourceFileName)
CopyBuffer = Space$(25000) 'AS LARGE AS POSSIBLE UNDER 65,000
'--KILL THE CURRENT TARGET FILE IF IT EXISTS
If Len(Dir$(TargetFileName)) Then
Kill TargetFileName
End If
'--OPEN FILES
SourceFileNo = FreeFile
Open SourceFileName For Binary Access Read As SourceFileNo
TargetFileNo = FreeFile
Open TargetFileName For Binary Access Write As TargetFileNo
'--COPY SOURCE FILE TO TARGET FILE
For I = 1 To SourceFileSize \ Len(CopyBuffer)
Get #SourceFileNo, , CopyBuffer
ProgressGuage.FloodPercent = I * Len(CopyBuffer) / SourceFileSize * 100
'UPDATE PROGRESS GUAGE
Put #TargetFileNo, , CopyBuffer
DoEvents
Next I
'--COPY ANY ODD PORTION OF THE SOURCE FILE REMAINING
Use this code with the Startup form procedure. Use CenterMe for non-MDI windows such as a dialog box. You should use CenterMe BEFORE you use Show to display the form. For two reasons:
1.) If you use CenterMe after Show, you will see the form move at run-time. This looks very unprofessional.
2.) If you display the form as modal (form.Show 1) and then use CenterMe, Visual Basic won't listen to the next command following Show until your new form is removed from the screen. You can use CenterMe in the Form_Load event, causing the form to be centered each time it's loaded, or before the Show method.
You can use CenterMe in the Form_Resize event. This will make the window always centered, even if the user changes the size of your form.
[Code]
Sub CenterMe (frm as Form)
Dim x, y 'New directions for the form
x = (Screen.Width - frm.Width) / 2
y = (Screen.Height - frm.Height) / 2
frm.Move x, y 'Change the location of the form
End Sub
[Stop]
[24]
This routine will move a menu caption to the far right of a menu. (Usually this is the Help caption.)
[Code]
Form_Load event.
Menu.Caption= Chr$(8) & Menu.Caption
'Replace Menu with a real control menu name such as menuHelp.
[Stop]
[25]
Discarding Letters: The following code only accepts the digits zero through nine.
[Code]
Sub Text1_KeyPress (KeyAscii As Integer)
If KeyAscii < Asc (" ") Then 'Is this Control Char
Exit Sub
End If
If KeyAscii < Asc ("0") Or KeyAscii > Asc ("9") Then
KeyAscii = 0
End If
End Sub
[Stop]
[26]
This subroutine (DoKeyPress) discards any characters that can't be in a number format. The only characters allowed are:
0 - 9 All digits
- A minus, only if it is the first character
. Periods are allowed
[Code]
'Type this code in a module or the declarations of a form.
'There is also another subroutine DoKeyPress uses, CheckPeriod.
Sub DoKeyPress (t As Control, KeyAscii As Integer)
If KeyAscii < Asc(" ") Then ' Is this Control char?
Exit Sub ' Yes, let it pass
End If
CheckPeriod t ' Remove excess periods
If KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Then
' keep digit
ElseIf KeyAscii = Asc(".") Then
' keep .
ElseIf KeyAscii = Asc("-") And t.SelStart = 0 Then
' Keep - only if first char
Else
KeyAscii = 0 ' Discard all other chars
End If
' This code keeps you from typing any characters in front of
' a minus sign.
If Mid$(t.Text, t.SelStart + t.SelLength + 1, 1) = "-" Then
KeyAscii = 0 ' Discard chars before -
End If
End Sub
[Stop]
[27]
Use this with the DoKeyPress subroutine. The subroutine, DoKeyPress needs the procedure. This subroutine makes sure a text box never has more than one period in it. You can also use this subroutine separate with your project.
[Code]
Sub CheckPeriod (t As Control)
Dim i As Integer
i = InStr(1, t.Text, ".") ' Look for a period
If i > 0 And InStr(i + 1, t.Text, ".") > 0 Then
t.SelStart = t.SelStart - 1
t.SelLength = 1 ' Select new period
t.SelText = "" ' Remove new period
End If
End Sub
[Stop]
[28]
The Visual Basic textbox control does not support Overtype mode. Add this code to a textbox to enable the Insert key.
[Code]
Sub Text1_KeyPress (KeyAscii As Integer)
If KeyAscii <> 8 And KeyAscii <> 13 And Text1.SelLength = 0 Then
Text1.SelLength = 1
End If
End Sub
[Stop]
[29]
How to format a floppy disk from Visual Basic.
[Code]
'Declares for Format a Floppy Disk
Type Rect
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
Declare Sub GetWindowRect Lib "User" (ByVal hWnd As Integer, lpRect As Rect)
Declare Function IsWindow Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function WinExec Lib "Kernel" (ByVal lpCmdLine As String, ByVal nCmdShow As Integer) As Integer
Declare Function SetActiveWindow Lib "User" (ByVal hWnd As Integer) As Integer Declare Function GetActiveWindow Lib "User" () As Integer
Declare Function LockWindowUpdate Lib "User" (ByVal hwndLock As Integer) As Integer
Declare Function GetDesktopWindow Lib "User" () As Integer
Declare Function FindWindow Lib "User" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Integer
Declare Function PostMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Long) As Integer
Const WM_COMMAND = &H111
Const WM_CLOSE = &H10
Dim wFlag%
Dim lpDlgRect As Rect
Dim lpDskRect As Rect
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Sub CenterDialog (WinText As String)
Do
If FindWindow(0&, WinText) Then Exit Do
x% = DoEvents()
Loop
wnd% = GetActiveWindow()
Call GetWindowRect(wnd%, lpDlgRect)
wdth% = lpDlgRect.Right - lpDlgRect.Left
hght% = lpDlgRect.Bottom - lpDlgRect.Top
Call GetWindowRect(GetDesktopWindow(), lpDskRect)
Scrwdth% = lpDskRect.Right - lpDskRect.Left
Scrhght% = lpDskRect.Bottom - lpDskRect.Top
x% = (Scrwdth% - wdth%) / 2
Y% = (Scrhght% - hght%) / 2
Call SetWindowPos(wnd%, 0, x%, Y%, 0, 0, SWP_NOZORDER Or SWP_NOSIZE)
End Sub
Sub FMFormat (F As Form)
FMhWnd = FindWindow("WFS_Frame", 0&)
If FMhWnd = 0 Then
i% = WinExec("Winfile", 0)
FMhWnd = FindWindow("WFS_Frame", 0&)
If FMhWnd = 0 Then
MsgBox "FileMan ain't home"
Exit Sub
End If
wFlag = 1
End If
i% = LockWindowUpdate(GetDesktopWindow())
i% = PostMessage(FMhWnd, WM_COMMAND, &HCB, 0)
Call CenterDialog("Format Disk")
i% = LockWindowUpdate(0)
wnd% = GetActiveWindow()
While IsWindow(wnd%)
x = DoEvents()
Wend
x = DoEvents()
If wFlag Then
wFlag = 0
i% = PostMessage(FMhWnd, WM_CLOSE, 0, 0)
End If
i% = SetActiveWindow(F.hWnd)
End Sub
[Stop]
[30]
This routine allows you the dynamically remove the title bar from a VB form.
[Code]
'Declares for Remove Title Bar
DefInt A-Z
Option Explicit
Declare Function GetWindowWord% Lib "User" (ByVal hWnd%, ByVal nIndex%)
Declare Function SetWindowWord% Lib "User" (ByVal hWnd%, ByVal nIndex%,
ByVal w
NewWord%)
Declare Function GetWindowLong& Lib "User" (ByVal hWnd%, ByVal nIndex%)
Declare Function SetWindowLong& Lib "User" (ByVal hWnd%, ByVal nIndex%, ByVal
d
wNewLong&)
Const GWW_ID = (-12)
Const GWL_STYLE = (-16)
Const WS_DLGFRAME = &H400000
Const WS_SYSMENU = &H80000
Const WS_MINIMIZEBOX = &H20000
Const WS_MAXIMIZEBOX = &H10000
Sub TitleBar (frm As Form, ShowTitle)
Static Oldhmenu, SavedStyle&
Dim NewStyle&, t&
If ShowTitle Then
'get the current style attributes
NewStyle& = GetWindowLong&(frm.hWnd, GWL_STYLE)
'set only the attributes that were removed earlier
How to make a textbox read only and how to prevent the user from changing the text.
[Code]
'Declares for Read Only Text Box
Global Const WM_USER = &H400
Global Const EM_SETREADONLY = (WM_USER + 31)
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
SendMessage(Text1.hWnd, EM_SETREADONLY, 1, 0)
[Stop]
[33]
To create a tool box for an application, simply set up a form as a parent and another form as a the toolbox/floating dialog whatever. If you try tbox.show 1 i.e. modal you'll find the form will show but you will be unable to do anything with it. Secondly you absolutely *MUST* unload the child form i.e.
tbox BEFORE unloading the main form otherwise your program will crash.
[Code]
'Declares for Tool Box
'In a suitable declarations section declare the API function as follows:
Declare Function SetParent% Lib "User" (ByVal hWndChild%, ByVal hWndNewParent%)
Sub ShowTbox_Click ()
Dim ret As Integer
If doshow = False Then 'toolbox not visible
ret = SetParent(tbox.hWnd, parent.hWnd) 'this makes the toolbox float
tbox.Left = 0 'sets position to top left corner of parent
tbox.Top = 0
tbox.Show 'makes toolbox visible
'try tbox.show 1 i.e. modal to see what happens
doshow = True
Showtbox.Caption = "&Hide Toolbox"
Else
tbox.Hide
doshow = False
Showtbox.Caption = "&Show Toolbox"
End If
End Sub
[Stop]
[34]
Listed below is a subroutine that will quit windows in three different ways if needed. Passing 1 to it will reboot the computer, passing 2 will restart Windows, and passing 3 will exit Windows and return to DOS.
[Code]
'Declares for Restart/Exit Windows
Declare Function ExitWindows Lib "User" (ByVal RestartCode As Long,ByVal
DOSReturnCode As Integer) As Integer
'Add this subroutine to a module:
Sub ExitWin (ByVal nExitOption As Integer) Dim n As Integer
n = MsgBox("Do you really want to exit Windows?", 36, "Exiting")
If n = 7 Then Exit Sub 'User chose NO
Select Case nExitOption
Case 1
n = ExitWindows(67, 0) 'reboot the computer
Case 2
n = ExitWindows(66, 0) 'restart Windows
Case 3
n = ExitWindows(0, 0) 'exit Windows
End Select
End Sub
[Stop]
[35]
How do you write a code that checks if the user chose Yes instead of No in a msgbox? Or Yes instead of Cancel?
[Code]
Dim Msg
Msg = "Pick Yes or No" 'Here's a message
If MsgBox(Msg$, 4 + 32 + 256) <> 6 Then 'Msgbox with a question mark
'andYES/ NO buttons.
Msgbox "You chose No"
Else
Msgbox "You chose Yes"
End If
'This is what it means:
'IF MsgBox(Msg.....) <> 6 Then
'If the user chose anything besides Yes (Yes means 6) then
'.... do whatever needs to be done.
'End If
[Stop]
[36]
Set the Timer's Interval to 60,000 put the following into the Timer_Timer event. This code will trigger code in 5 minutes. Great for an auto save routine!
[Code]
Static Counter As Integer
Counter% = Counter% + 1
If Counter% = 5 Then
Counter% = 0 'insert this line if you want the counter to reset
itself when it reaches 5 mins
[YOUR CODE GOES HERE]
End If
[Stop]
[37]
How to make a backgorund of a form have a gradiated style of backgorund.
Special thanks to: JwpcEMail@aol.com
[Code]
'Declares for Gradient Background Color
Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
' API Functions used to create solid brush and draw brush on form
Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
Declare Function FillRect Lib "User" (ByVal hDC As Integer, lpRect As RECT, ByVal hBrush As Integer) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
Dim hBrush%
'Place the follwing two routines into the main form
Sub Form_Paint ()
fadeform Me
End Sub
Sub Form_Resize ()
fadeform Me
End Sub
'Place the following code in a the general declarations of
'a .bas file called: Fade.bas
Sub fadeform (TheForm As Form)
Dim FormHeight%, red%, StepInterval%, X%, RetVal%, OldMode%
